(in-package #:experiment)

(define-condition onward ()
  ((return-value :initarg :return :accessor onward-return-value))
  (:report (lambda (c stream)
             (format stream "Onward request with return value: ~s"
                     (onward-return-value c)))))

(define-condition navigation ()
  ())

(define-condition forward (navigation)
  ()
  (:report (lambda (c stream)
             (declare (ignore c))
             (format stream "forward request"))))

(define-condition backward (navigation)
  ()
  (:report (lambda (c stream)
             (declare (ignore c))
             (format stream "backward request"))))

(define-condition jump (navigation)
  ((index :initarg :index :accessor jump-index))
  (:report (lambda (c stream)
             (format stream "Jump requested to index ~d" (jump-index c)))))

(defclass state (gwee:view)
  ((first-time-p :initform t)
   (checkpointp :initarg :checkpointp :initform *default-checkpointp* :accessor checkpointp)))

(defgeneric state-run (experiment state))
(defgeneric state-init (experiment state))
(defgeneric state-end (experiment state))
(defgeneric state-clean-up (experiment state)
  (:method-combination progn :most-specific-last))
(defgeneric state-dispatch-event (experiment state event))
(defgeneric state-translate-action (state name &rest args &key &allow-other-keys)
  (:documentation "Allow states to have alternate actions that are
more user-friendly for model developers. The action is translated into
the corresponding native action and executed."))
(defgeneric state-unhandled-event (experiment state event))
(defgeneric state-onward (experiment state &optional retval))
(defgeneric state-backward (experiment state)
  (:documentation "Go to the previous state. This is usually used for
debugging or exploring."))
(defgeneric state-dump (experiment state)
  (:method-combination append :most-specific-last))
(defgeneric state-list-actions (experiment state)
  (:method-combination append :most-specific-last)
  (:documentation "List possible actions given the current state."))
(defgeneric state-list-objects (experiment state)
  (:method-combination append :most-specific-last)
  (:documentation "List possible actions given the current state."))
(defgeneric compile-state (experiment state args))
(defgeneric state-translate-event (experiment state model-action &key))

(defun default-list-event-translations (state)
  (remove-duplicates
   (mapcan (lambda (a)
             (let* ((e (action-event-match-template a))
                    (matcher (find (match-template-name e)
                                   *event-matchers*
                                   :key 'event-match-name))
                    (trans (u:collect-with (e *translation-list*
                                            :key 'event-translation-event-name)
                             (eq (event-match-event-name matcher) e))))
               (assert trans ()
                       "Cannot find event translation for ~a (~a)" (match-template-name e) (action-name a))
               (loop for i in trans
                     collect (list* (event-translation-name i)
                                    (mapcan (lambda (k)
                                              (list (intern (string k) :keyword)
                                                    :value-needed))
                                            (event-translation-keys i))))))
           (possible-actions state))
   :key 'first))

(defmethod state-translate-action (state name &rest keys &key &allow-other-keys)
  (let* ((actions (possible-actions state))
         (trans (remove-duplicates
                 (loop for a in actions
                       for matcher = (find (match-template-name
                                            (action-event-match-template a))
                                           *event-matchers*
                                           :key 'event-match-name)
                       for i = (u:collect-with (e *translation-list*)
                                 (and (eq (event-match-event-name matcher)
                                          (event-translation-event-name e))
                                      (string= name
                                               (event-translation-name e))))
                       append i))))
    (assert (<= (length trans) 1) ()
            "~a matches for ~a translation. Should be one or none." name (length trans))
    (if trans
        (dolist (i trans)
          (state-dispatch-event *experiment*
                                state
                                (apply (event-translation-generic i)
                                       *experiment* state keys)))
        (error "~s did not execute anything for the state ~a" (list* name keys) (type-of state)))))

(defmethod state-clean-up progn (experiment (state state))
  nil)

(defmethod state-end (experiment (state state))
  (log experiment 'end))

(defmethod state-init (experiment (state state))
  )

(defmethod state-dump append (experiment (state t))
  `(,(type-of state) :checkpointp ,(checkpointp state)))

(defmethod state-run :around (experiment (state state))
  (with-current-state (experiment state)
    (when (checkpointp state) (save-experiment experiment))
    (unwind-protect
         (prog1
             (handler-case
                 (progn
                   ;; We need to make sure the new state is visible.
                   (setf (gwee:switchable-layout-current-view experiment) state)
                   (when (slot-value state 'first-time-p)
                     (setf (slot-value state 'first-time-p) nil)
                     (state-init experiment state))
                   (call-next-method))
               (onward (c)
                 (onward-return-value c)))
           (state-end experiment state))
      (state-clean-up experiment state))))

(defmethod state-run (experiment (state state))
  (gwee:dispatch-events))

(defmethod state-list-actions append (experiment (state state))
  nil)

(defmethod state-list-objects append (experiment (state state))
  nil)

(defmethod state-list-actions append (experiment (state null))
  nil)

(defmethod state-list-objects append (experiment (state null))
  nil)

(defmethod state-onward (experiment (state state) &optional retval)
  (gwee:cancel-all-timers)
  (signal 'onward :return retval))

(defmethod state-dispatch-event (experiment state event)
  ;; FIXME: is this assertion needed?
  (assert (eq state (current-state experiment))
	  () "~a /= ~o" state (current-state experiment))
  ;;(print `(dispatch-event ,event))
  (unless (match-event-execute-actions state event)
    (state-unhandled-event experiment state event)))

(defmethod state-dispatch-event (experiment (state null) event)
  )

(defmethod state-unhandled-event (exp (state state) (event event))
  )

(defmethod state-backward (exp (state state))
  (gwee:cancel-all-timers)
  (signal 'backward))

(defmethod compile-state (experiment (state state) args)
  (apply 'make-instance (type-of state) :parent experiment args))

(defmethod compile-state (experiment (state symbol) args)
  (compile-state experiment (allocate-instance (find-class state)) args))
